﻿<%
	'微信接口函数
	Dim GetTokenUtl:GetTokenUtl="https://api.weixin.qq.com/cgi-bin/token?"	'获取access_token接口
	Dim SendMsgUrl:SendMsgUrl="https://api.weixin.qq.com/cgi-bin/message/custom/send?"	'发送消息接口
	Dim SendMenuUrl:SendMenuUrl="https://api.weixin.qq.com/cgi-bin/menu/"	'自定义菜单接口
	Dim GetUserListUrl:GetUserListUrl="https://api.weixin.qq.com/cgi-bin/user/get?"	'获取粉丝列表
	Dim GetUserInfoUrl:GetUserInfoUrl="https://api.weixin.qq.com/cgi-bin/user/info?"	'获取粉丝信息接口
	
	'被动返回文本消息
	function RequestSendText(fromusername,tousername,returnstr)
		RequestSendText="<xml>" &_
		"<ToUserName><![CDATA["&fromusername&"]]></ToUserName>" &_
		"<FromUserName><![CDATA["&tousername&"]]></FromUserName>" &_
		"<CreateTime>"&now&"</CreateTime>" &_
		"<MsgType><![CDATA[text]]></MsgType>" &_
		"<Content><![CDATA[" & dehtml(returnstr) & "]]></Content>" &_
		"</xml>"
	end function
	
	'被动返图文本消息	
	function RequestSendPicText(fromusername,tousername,title,descriptions,picurl,url)
		dim t:t="<xml>"
		t=t&"<ToUserName><![CDATA["&fromusername&"]]></ToUserName>"
		t=t&"<FromUserName><![CDATA["&tousername&"]]></FromUserName>"
		t=t&"<CreateTime>"&now&"</CreateTime>"
		t=t&"<MsgType><![CDATA[news]]></MsgType>"
		t=t&"<ArticleCount>1</ArticleCount>"
		t=t&"<Articles>"
		t=t&"<item>"
		t=t&"<Title><![CDATA["&title&"]]></Title>"
		if Cls.strlen(descriptions)>0 then
			t=t&"<Description><![CDATA["&descriptions&"]]></Description>"
		end if
		if Cls.strlen(picurl)>0 then		
			if InStr(LCase(PicUrl), "http://") <= 0 then
				if left(PicUrl,1)<>"/" then
					PicUrl=weburl&webroot&PicUrl
				else
					PicUrl=weburl&PicUrl			
				end if
			end if
			t=t&"<PicUrl><![CDATA["&picurl&"]]></PicUrl>"
		end if
		t=t&"<Url><![CDATA["&url&"]]></Url>"
		t=t&"</item>"
		t=t&"</Articles>"
		t=t&"</xml>"
		RequestSendPicText=t
	end function
	
	
	'查找关键字
	function GetPicMsgBack(keyword)
		keyword=Cls.enhtml(keyword)
		datadb=Cls.db.dbload("","id,content,types,PicMsgID,PicMsgListID","[sys_KeyWord]","keyword='"&keyword&"'","")
		response.Write(datadb(2,0))
		if ubound(datadb)>=0 then
			if datadb(2,0)="文本" then
				GetPicMsgBack=RequestSendText(FromUserName,ToUserName,datadb(1,0))
			elseif datadb(2,0)="图文" then
				dim datadb2:datadb2=Cls.db.dbload("","id,title,info,pic,types,url","[sys_PicMsg]","id="&datadb(3,0),"")
				if ubound(datadb2)>=0 then
					dim id:id=datadb2(0,0)
					dim title:title=datadb2(1,0)
					dim descriptions:descriptions=datadb2(2,0)
					dim picurl:picurl=datadb2(3,0)
					dim url
					if datadb2(4,0)="图文" then
						url=weburl&webroot&"show.asp?id="&datadb2(0,0)
					else
						url=datadb2(5,0)
						if instr(url,"?")>0 then
							url=url&"&FromUserName="&fromusername
						else
							url=url&"?FromUserName="&fromusername
						end if
					end if
					Cls.db.exedb("update [sys_KeyWord] set hits = hits + 1 where id ="&datadb(0,0))
					GetPicMsgBack=RequestSendPicText(fromusername,tousername,title,descriptions,picurl,url)
				else
					GetPicMsgBack="0000" '找不到图文信息
				end if
			else	'多图文
				datadb3=Cls.db.dbload("","p_IdList","[sys_PicMsgList]","p_Id="&datadb(4,0),"")
				if ubound(datadb3)>=0 then
					datadb2=Cls.db.dbload("","Id,Title,Info,Pic,types,content,url","[sys_PicMsg]","Id in ("&datadb3(0,0)&")","instr('"&datadb3(0,0)&",',','&Id&',')")
					if ubound(datadb2)>=0 then
						dim t:t="<xml>"
						t=t&"<ToUserName><![CDATA["&fromusername&"]]></ToUserName>"
						t=t&"<FromUserName><![CDATA["&tousername&"]]></FromUserName>"
						t=t&"<CreateTime>"&now&"</CreateTime>"
						t=t&"<MsgType><![CDATA[news]]></MsgType>"
						t=t&"<ArticleCount>"&ubound(datadb2,2)+1&"</ArticleCount>"
						t=t&"<Articles>"
						for i=0 to ubound(datadb2,2)
							Title=datadb2(1,i)
							Descriptions=datadb2(2,i)
							picurl=datadb2(3,i)
							if datadb2(4,i)="图文" then
								Url=weburl&webroot&"show.asp?id="&datadb2(0,i)
							else
								Url=datadb2(6,i)		
								if instr(url,"?")>0 then
									url=url&"&FromUserName="&fromusername
								else
									url=url&"?FromUserName="&fromusername
								end if
							end if
							t=t&"<item>"
							t=t&"<Title><![CDATA["&Title&"]]></Title>"
							if Cls.strlen(Descriptions)>0 then
								t=t&"<Description><![CDATA["&Descriptions&"]]></Description>"
							end if
							
							if Cls.strlen(picurl)>0 then		
								if InStr(LCase(PicUrl), "http://") <= 0 then
									if left(PicUrl,1)<>"/" then
										PicUrl=weburl&webroot&PicUrl
									else
										PicUrl=weburl&PicUrl			
									end if
								end if
								t=t&"<PicUrl><![CDATA["&picurl&"]]></PicUrl>"
							end if
							t=t&"<Url><![CDATA["&Url&"]]></Url>"
							t=t&"</item>"
						next
						t=t&"</Articles>"
						t=t&"</xml>"
						Cls.echo t
						cls.die
					end if
				end if
			end if
		else
			GetPicMsgBack="" '查无此关键字
		end if
	end function
	
	'调用关注回复
	function GetSubscribeBack()
		datadb=Cls.db.dbload("","Content,types,PicMsgID","[sys_Config]","id=1","")
		if datadb(1,0)="文本" then
			GetSubscribeBack=RequestSendText(FromUserName,ToUserName,datadb(0,0))
		else
			dim datadb2:datadb2=Cls.db.dbload("","id,title,info,pic,types,url","[sys_PicMsg]","id="&datadb(2,0),"")
			if ubound(datadb2)>=0 then
				dim id:id=datadb2(0,0)
				dim title:title=datadb2(1,0)
				dim descriptions:descriptions=datadb2(2,0)
				dim picurl:picurl=datadb2(3,0)
				dim types:types=datadb2(4,0)
				dim url:url=datadb2(5,0)
				'GetSubscribeBack=RequestSendPicText(FromUserName,ToUserName,id,title,descriptions,picurl,types,url)
				GetSubscribeBack=RequestSendPicText(fromusername,tousername,title,descriptions,picurl,url)
			else
				GetSubscribeBack="" '找不到图文信息
			end if
		end if
	End function
	
	'主动发送文本消息
	Function PostMsg(FromUserName,ToUserName,StrMsg)
		Access_token=GetToken()
		Sendtext="{""touser"":"""&ToUserName&""",""msgtype"":""text"",""text"":{""content"":"""&StrMsg&"""}}"
		strJson=PostURL(SendMsgUrl&"&access_token="&Access_token,Sendtext)
		Call InitScriptControl:Set objTest = getJSONObject(strJson)
		if objTest.errcode="0" then	
			'消息入库
			data=array(array("ToUserName",FromUserName,50,1),array("FromUserName",ToUserName,50,1),array("CreateTime",now(),50,1),array("MsgType","text",50,1),array("Content",StrMsg,0,1),array("BeiZhu","主动发送消息",0,1),array("Addtime",now(),50,1),array("reply","1",0,0))	
			Call Cls.db.dbnew("[sys_Msg]",data,"")
			PostMsg="1"
		else
			PostMsg="0发送失败，"&weixin_err(objTest.errcode)
		end if
	End Function
	
	'获取用户信息并入库
	Function GetUserInfo(id)
		Access_token=GetToken()
		strJson=GetURL(GetUserInfoUrl&"&access_token="&Access_token&"&openid="&id&"")
		Call InitScriptControl:Set objTest = getJSONObject(strJson)	
		'消息入库
		data=array(array("openid",objTest.openid,255,1),array("nickname",objTest.nickname,200,1),array("sex",objTest.sex,50,1),array("city",objTest.city,0,0),array("country",objTest.country,50,1),array("province",objTest.province,50,1),array("language",objTest.language,50,1),array("headimgurl",objTest.headimgurl,0,1),array("subscribe_time",FromUnixTime(objTest.subscribe_time),50,1))	
		call Cls.db.dbnew("[sys_User]",data,"FromUserName='"&FromUserName&"'")
	End Function
	
	'删除用户数据
	Function DelUser(id)
		Cls.db.dbdel "[sys_User]","openid='"&id&"'"
	End Function
	
	'获取最新Access_token
	Private function GetToken()
		dim datadb
		datadb=Cls.db.dbload("","AppId,Appsecret,Access_token,Token_Time,Expires_In","[sys_Config]","id=1","")	
		AppId=datadb(0,0)
		Appsecret=datadb(1,0)
		Access_token=datadb(2,0)
		Token_Time=datadb(3,0)
		Expires_In=datadb(4,0)
		GetToken=Access_token
		If datediff("s",Token_Time,Now())>Expires_In then '当Access_token过期时，重新获取新Access_token
			strJson=GetURL(GetTokenUtl&"grant_type=client_credential&appid="&AppId&"&secret="&Appsecret&"")
			if InStr(strJson,"errcode")>0 then GetToken="":exit function
			Call InitScriptControl:Set objTest = getJSONObject(strJson)
			Access_token=objTest.access_token	'获取新Access_token
			Expires_In=objTest.expires_in	
			'Access_token入库
			data=array(array("Access_token",Access_token,0,1),array("Expires_In",Expires_In,0,0),array("Token_Time",now(),50,1))	
			call Cls.db.dbupdate("[sys_Config]","id=1",data)
			GetToken=Access_token
		End If
	End function
	
	'Post内容
	Function PostURL(url,PostStr)
		Set Retrieval = Server.CreateObject("Msxml2.ServerXMLHTTP")
		With Retrieval
			.Open "POST", url, false ,"" ,""
			.setRequestHeader "Content-Type","application/x-www-form-urlencoded"
			.Send(PostStr)
			PostURL = .responsetext
		End With
		Set Retrieval = Nothing
		'response.Write PostURL
	End Function
	
	'Get内容
	Function GetURL(url)	
		dim http
		set http=server.createobject("Msxml2.ServerXMLHTTP")
			http.open "GET",url,false
			http.setRequestHeader "If-Modified-Since","0"
			http.send()
			GetURL=http.responsetext
		set http=nothing
		'response.Write GetURL	
	End Function
	
	'时间戳转换成普通日期
	Function FromUnixTime(intTime) 
		If IsEmpty(intTime) Or Not IsNumeric(intTime) Then 
			FromUnixTime = Now() 
			Exit Function 
		End If 	
		FromUnixTime = DateAdd("s", intTime, "1970-1-1 0:0:0") 
		FromUnixTime = DateAdd("h", 8, FromUnixTime) 
	End Function
	
	'解析json
	'Call InitScriptControl
	'Set objTest = getJSONObject(strTest)  
	Dim sc4Json   
	Sub InitScriptControl    
		Set sc4Json = Server.CreateObject("MSScriptControl.ScriptControl")    
		sc4Json.Language = "JavaScript"    
		sc4Json.AddCode "var itemTemp=null;function getJSArray(arr, index){itemTemp=arr[index];}"    
	End Sub 
	Function getJSONObject(strJSON)    
		sc4Json.AddCode "var jsonObject = " & strJSON    
		Set getJSONObject = sc4Json.CodeObject.jsonObject    
	End Function 
	Sub getJSArrayItem(objDest,objJSArray,index)    
		On Error Resume Next    
		sc4Json.Run "getJSArray",objJSArray, index    
		Set objDest = sc4Json.CodeObject.itemTemp    
		If Err.number=0 Then Exit Sub    
		objDest = sc4Json.CodeObject.itemTemp    
	End Sub
	''转换HTML代码，过滤代码
	public function enhtml(byval t0)
		if isnull(t0) then enhtml="":exit function
		if t0="<p>&nbsp;</p>" then enhtml="":exit function
		t0=replace(t0,"&","&amp;")
		t0=replace(t0,"'","&#39;")
		t0=replace(t0,"""","&#34;")
		t0=replace(t0,"<","&lt;")
		t0=replace(t0,">","&gt;")
		set reg=new regexp
		reg.ignorecase=true
		reg.global=true
		reg.pattern="(w)(here)"
		t0=reg.replace(t0,"$1h&#101;re")
		reg.pattern="(s)(elect)"
		t0=reg.replace(t0,"$1el&#101;ct")
		reg.pattern="(i)(nsert)"
		t0=reg.replace(t0,"$1ns&#101;rt")
		reg.pattern="(c)(reate)"
		t0=reg.replace(t0,"$1r&#101;ate")
		reg.pattern="(d)(rop)"
		t0=reg.replace(t0,"$1ro&#112;")
		reg.pattern="(a)(lter)"
		t0=reg.replace(t0,"$1lt&#101;r")
		reg.pattern="(d)(elete)"
		t0=reg.replace(t0,"$1el&#101;te")
		reg.pattern="(u)(pdate)"
		t0=reg.replace(t0,"$1p&#100;ate")
		reg.pattern="(\s)(or)"
		t0=reg.replace(t0,"$1o&#114;")
		reg.pattern="(java)(script)"
		t0=reg.replace(t0,"$1scri&#112;t")
		reg.pattern="(j)(script)"
		t0=reg.replace(t0,"$1scri&#112;t")
		reg.pattern="(vb)(script)"
		t0=reg.replace(t0,"$1scri&#112;t")
		if instr(t0,"expression")<>0 then
			t0=replace(t0,"expression","e&#173;xpression",1,-1,0)
		end if
		enhtml=t0
	end function
	
	''逆向转换HTML
	function dehtml(byval t0)
		if isnull(t0) then
			dehtml=""
			exit function
		end if
		t0=replace(t0,"&amp;","&")
		t0=replace(t0,"&#39;","'")
		t0=replace(t0,"&#34;","""")
		t0=replace(t0,"&lt;","<")
		t0=replace(t0,"&gt;",">")
		t0=replace(t0,chr(10),vbcrlf)
		dehtml=t0
	end function
%>